home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / base64.el.z / base64.el
Encoding:
Text File  |  1998-05-21  |  9.3 KB  |  275 lines
  1. ;;; base64.el,v --- Base64 encoding functions
  2. ;; Author: Kyle E. Jones
  3. ;; Created: 1997/03/12 14:37:09
  4. ;; Version: 1.6
  5. ;; Keywords: extensions
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (C) 1997 Kyle E. Jones
  9. ;;;
  10. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  11. ;;;
  12. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;;; it under the terms of the GNU General Public License as published by
  14. ;;; the Free Software Foundation; either version 2, or (at your option)
  15. ;;; any later version.
  16. ;;;
  17. ;;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;;; GNU General Public License for more details.
  21. ;;;
  22. ;;; You should have received a copy of the GNU General Public License
  23. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25. ;;; Boston, MA 02111-1307, USA.
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27.  
  28. ;; For non-MULE
  29. (if (not (fboundp 'char-int))
  30.     (fset 'char-int 'identity))
  31.  
  32. (defvar base64-alphabet
  33.   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  34.  
  35. (defvar base64-decoder-program nil
  36.   "*Non-nil value should be a string that names a MIME base64 decoder.
  37. The program should expect to read base64 data on its standard
  38. input and write the converted data to its standard output.")
  39.  
  40. (defvar base64-decoder-switches nil
  41.   "*List of command line flags passed to the command named by
  42. base64-decoder-program.")
  43.  
  44. (defvar base64-encoder-program nil
  45.   "*Non-nil value should be a string that names a MIME base64 encoder.
  46. The program should expect arbitrary data on its standard
  47. input and write base64 data to its standard output.")
  48.  
  49. (defvar base64-encoder-switches nil
  50.   "*List of command line flags passed to the command named by
  51. base64-encoder-program.")
  52.  
  53. (defconst base64-alphabet-decoding-alist
  54.   '(
  55.     ( ?A . 00) ( ?B . 01) ( ?C . 02) ( ?D . 03) ( ?E . 04) ( ?F . 05)
  56.     ( ?G . 06) ( ?H . 07) ( ?I . 08) ( ?J . 09) ( ?K . 10) ( ?L . 11)
  57.     ( ?M . 12) ( ?N . 13) ( ?O . 14) ( ?P . 15) ( ?Q . 16) ( ?R . 17)
  58.     ( ?S . 18) ( ?T . 19) ( ?U . 20) ( ?V . 21) ( ?W . 22) ( ?X . 23)
  59.     ( ?Y . 24) ( ?Z . 25) ( ?a . 26) ( ?b . 27) ( ?c . 28) ( ?d . 29)
  60.     ( ?e . 30) ( ?f . 31) ( ?g . 32) ( ?h . 33) ( ?i . 34) ( ?j . 35)
  61.     ( ?k . 36) ( ?l . 37) ( ?m . 38) ( ?n . 39) ( ?o . 40) ( ?p . 41)
  62.     ( ?q . 42) ( ?r . 43) ( ?s . 44) ( ?t . 45) ( ?u . 46) ( ?v . 47)
  63.     ( ?w . 48) ( ?x . 49) ( ?y . 50) ( ?z . 51) ( ?0 . 52) ( ?1 . 53)
  64.     ( ?2 . 54) ( ?3 . 55) ( ?4 . 56) ( ?5 . 57) ( ?6 . 58) ( ?7 . 59)
  65.     ( ?8 . 60) ( ?9 . 61) ( ?+ . 62) ( ?/ . 63)
  66.    ))
  67.  
  68. (defvar base64-alphabet-decoding-vector
  69.   (let ((v (make-vector 123 nil))
  70.     (p base64-alphabet-decoding-alist))
  71.     (while p
  72.       (aset v (car (car p)) (cdr (car p)))
  73.       (setq p (cdr p)))
  74.     v))
  75.  
  76. (defun base64-run-command-on-region (start end output-buffer command
  77.                        &rest arg-list)
  78.   (let ((tempfile nil) status errstring)
  79.     (unwind-protect
  80.     (progn
  81.       (setq tempfile (make-temp-name "base64"))
  82.       (setq status
  83.         (apply 'call-process-region
  84.                start end command nil
  85.                (list output-buffer tempfile)
  86.                nil arg-list))
  87.       (cond ((equal status 0) t)
  88.         ((zerop (save-excursion
  89.               (set-buffer (find-file-noselect tempfile))
  90.               (buffer-size)))
  91.          t)
  92.         (t (save-excursion
  93.              (set-buffer (find-file-noselect tempfile))
  94.              (setq errstring (buffer-string))
  95.              (kill-buffer nil)
  96.              (cons status errstring)))))
  97.       (condition-case ()
  98.       (delete-file tempfile)
  99.     (error nil)))))
  100.  
  101. (defun base64-insert-char (char &optional count ignored buffer)
  102.   (condition-case nil
  103.       (progn
  104.     (insert-char char count ignored buffer)
  105.     (fset 'base64-insert-char 'insert-char))
  106.     (wrong-number-of-arguments
  107.      (fset 'base64-insert-char 'base64-xemacs-insert-char)
  108.      (base64-insert-char char count ignored buffer))))
  109.  
  110. (defun base64-xemacs-insert-char (char &optional count ignored buffer)
  111.   (if (and buffer (eq buffer (current-buffer)))
  112.       (insert-char char count)
  113.     (save-excursion
  114.       (set-buffer buffer)
  115.       (insert-char char count))))
  116.  
  117. (defun base64-decode-region (start end)
  118.   (interactive "r")
  119.   (message "Decoding base64...")
  120.   (let ((work-buffer nil)
  121.     (done nil)
  122.     (counter 0)
  123.     (bits 0)
  124.     (lim 0) inputpos
  125.     (non-data-chars (concat "^=" base64-alphabet)))
  126.     (unwind-protect
  127.     (save-excursion
  128.       (setq work-buffer (generate-new-buffer " *base64-work*"))
  129.       (buffer-disable-undo work-buffer)
  130.       (if base64-decoder-program
  131.           (let* ((binary-process-output t) ; any text already has CRLFs
  132.              (status (apply 'base64-run-command-on-region
  133.                    start end work-buffer
  134.                    base64-decoder-program
  135.                    base64-decoder-switches)))
  136.         (if (not (eq status t))
  137.             (error "%s" (cdr status))))
  138.         (goto-char start)
  139.         (skip-chars-forward non-data-chars end)
  140.         (while (not done)
  141.           (setq inputpos (point))
  142.           (cond
  143.            ((> (skip-chars-forward base64-alphabet end) 0)
  144.         (setq lim (point))
  145.         (while (< inputpos lim)
  146.           (setq bits (+ bits 
  147.                 (aref base64-alphabet-decoding-vector
  148.                       (char-int (char-after inputpos)))))
  149.           (setq counter (1+ counter)
  150.             inputpos (1+ inputpos))
  151.           (cond ((= counter 4)
  152.              (base64-insert-char (lsh bits -16) 1 nil work-buffer)
  153.              (base64-insert-char (logand (lsh bits -8) 255) 1 nil
  154.                      work-buffer)
  155.              (base64-insert-char (logand bits 255) 1 nil
  156.                          work-buffer)
  157.              (setq bits 0 counter 0))
  158.             (t (setq bits (lsh bits 6)))))))
  159.           (cond
  160.            ((= (point) end)
  161.         (if (not (zerop counter))
  162.             (error "at least %d bits missing at end of base64 encoding"
  163.                (* (- 4 counter) 6)))
  164.         (setq done t))
  165.            ((= (char-after (point)) ?=)
  166.         (setq done t)
  167.         (cond ((= counter 1)
  168.                (error "at least 2 bits missing at end of base64 encoding"))
  169.               ((= counter 2)
  170.                (base64-insert-char (lsh bits -10) 1 nil work-buffer))
  171.               ((= counter 3)
  172.                (base64-insert-char (lsh bits -16) 1 nil work-buffer)
  173.                (base64-insert-char (logand (lsh bits -8) 255)
  174.                        1 nil work-buffer))
  175.               ((= counter 0) t)))
  176.            (t (skip-chars-forward non-data-chars end)))))
  177.       (or (markerp end) (setq end (set-marker (make-marker) end)))
  178.       (goto-char start)
  179.       (insert-buffer-substring work-buffer)
  180.       (delete-region (point) end))
  181.       (and work-buffer (kill-buffer work-buffer))))
  182.   (message "Decoding base64... done"))
  183.  
  184. (defun base64-encode-region (start end)
  185.   (interactive "r")
  186.   (message "Encoding base64...")
  187.   (let ((work-buffer nil)
  188.     (counter 0)
  189.     (cols 0)
  190.     (bits 0)
  191.     (alphabet base64-alphabet)
  192.     inputpos)
  193.     (unwind-protect
  194.     (save-excursion
  195.       (setq work-buffer (generate-new-buffer " *base64-work*"))
  196.       (buffer-disable-undo work-buffer)
  197.       (if base64-encoder-program
  198.           (let ((status (apply 'base64-run-command-on-region
  199.                    start end work-buffer
  200.                    base64-encoder-program
  201.                    base64-encoder-switches)))
  202.         (if (not (eq status t))
  203.             (error "%s" (cdr status))))
  204.         (setq inputpos start)
  205.         (while (< inputpos end)
  206.           (setq bits (+ bits (char-int (char-after inputpos))))
  207.           (setq counter (1+ counter))
  208.           (cond ((= counter 3)
  209.              (base64-insert-char (aref alphabet (lsh bits -18)) 1 nil
  210.                      work-buffer)
  211.              (base64-insert-char
  212.               (aref alphabet (logand (lsh bits -12) 63))
  213.               1 nil work-buffer)
  214.              (base64-insert-char
  215.               (aref alphabet (logand (lsh bits -6) 63))
  216.               1 nil work-buffer)
  217.              (base64-insert-char
  218.               (aref alphabet (logand bits 63))
  219.               1 nil work-buffer)
  220.              (setq cols (+ cols 4))
  221.              (cond ((= cols 72)
  222.                 (base64-insert-char ?\n 1 nil work-buffer)
  223.                 (setq cols 0)))
  224.              (setq bits 0 counter 0))
  225.             (t (setq bits (lsh bits 8))))
  226.           (setq inputpos (1+ inputpos)))
  227.         ;; write out any remaining bits with appropriate padding
  228.         (if (= counter 0)
  229.         nil
  230.           (setq bits (lsh bits (- 16 (* 8 counter))))
  231.           (base64-insert-char (aref alphabet (lsh bits -18)) 1 nil
  232.                   work-buffer)
  233.           (base64-insert-char (aref alphabet (logand (lsh bits -12) 63))
  234.                   1 nil work-buffer)
  235.           (if (= counter 1)
  236.           (base64-insert-char ?= 2 nil work-buffer)
  237.         (base64-insert-char (aref alphabet (logand (lsh bits -6) 63))
  238.                     1 nil work-buffer)
  239.         (base64-insert-char ?= 1 nil work-buffer)))
  240.         (if (> cols 0)
  241.         (base64-insert-char ?\n 1 nil work-buffer)))
  242.       (or (markerp end) (setq end (set-marker (make-marker) end)))
  243.       (goto-char start)
  244.       (insert-buffer-substring work-buffer)
  245.       (delete-region (point) end))
  246.       (and work-buffer (kill-buffer work-buffer))))
  247.   (message "Encoding base64... done"))
  248.  
  249. (defun base64-encode (string)
  250.   (save-excursion
  251.     (set-buffer (get-buffer-create " *base64-encode*"))
  252.     (erase-buffer)
  253.     (insert string)
  254.     (base64-encode-region (point-min) (point-max))
  255.     (skip-chars-backward " \t\r\n")
  256.     (delete-region (point-max) (point))
  257.     (prog1
  258.     (buffer-string)
  259.       (kill-buffer (current-buffer)))))
  260.  
  261. (defun base64-decode (string)
  262.   (save-excursion
  263.     (set-buffer (get-buffer-create " *base64-decode*"))
  264.     (erase-buffer)
  265.     (insert string)
  266.     (base64-decode-region (point-min) (point-max))
  267.     (goto-char (point-max))
  268.     (skip-chars-backward " \t\r\n")
  269.     (delete-region (point-max) (point))
  270.     (prog1
  271.     (buffer-string)
  272.       (kill-buffer (current-buffer)))))  
  273.  
  274. (provide 'base64)
  275.